Tech Arsenal 2/Tech Arsenal 2 (Arsenal Computer).iso/clipper/s93bsp.exe/QBPROCS.PRG

Text File | 1993-08-11 | 15.5 KB | 742 lines

procedure QBMESS
*   Q B M E S S . P R G
* Print a MSG and wait for key stroke
PARAMETER MSG, colparam, waitime
private MEM
*    Last change:  MIB  11 Aug 93    4:40 pm

do case
case PCOUNT()=0
    MSG = "Press any key to continue..."
    colparam = COLMENU
    waitime = -1
case PCOUNT()=1
    colparam=colnorm
    waitime=0
case PCOUNT()=2
    waitime=0
endcase

@ QBMSGLIN,0 CLEAR to QBMSGLIN+1,79
set color to (colparam)
@ QBMSGLIN,centre(trim(MSG),79) say trim(MSG)
set color to (colnorm)
do case
case waitime > 0
    inkey(waitime)
    @ QBMSGLIN,0 CLEAR to QBMSGLIN+1,79
case waitime < 0
    set cursor off
    mem=" "
    set color to (colpwd)
    @ QBMSGLIN,0 get mem
    read
    set color to (colnorm)
    @ QBMSGLIN,0 CLEAR to QBMSGLIN+1,79
    set cursor on
endcase

RETURN

******************************************************************

procedure QBCLMESS
*       Q B C L M E S S
*       Clear the message box

set color to (colnorm)
@ QBMSGLIN,0 CLEAR to QBMSGLIN+1,79

RETURN

******************************************************************

function QBPROMPT

*   Q B P R O M P T . P R G
*   Prompt user for single letter command

PARAMETER CMDS,MSG, CMDNO
PRIVATE NCMDS, COLNO, I, MCHR
store 1 to N1
set message to QBMSGLIN+1 center
if pcount()=1
    MSG = "Select with first character, or "+chr(27)+" "+chr(26)+" and ┘"
elseif pcount()=2
    CMDNO = QBCHOICE
endif
MCHR = ""

ncmds = chrcount("|",CMDS)
COLNO = centre(cmds+space(NCMDS),79)

CLEAR typeahead
do QBCLMESS
set color to (COLMENU)
for I=1 to NCMDS
    N2 = atnext("|",CMDS,I)

    @ QBMSGLIN, COLNO prompt substr(CMDS,N1,N2-N1) message MSG
    MCHR = MCHR + substr(CMDS,N1,1)
    COLNO = col() + 2
    N1 = N2 + 1
next
menu to CMDNO
QBKEY = lastkey()
if CMDNO=0
    GETOUT = .t.
    QBCHOICE = 0
    QBRESP="Q"
    QBKEY = 27
else
    QBRESP = substr(MCHR,CMDNO,1)
    QBCHOICE = CMDNO
    GETOUT = .f.
endif
do QBCLMESS

RETURN CMDNO

******************************************************************

procedure QBBOX

* Q B B O X
Parameters WIDTH
PRIVATE ulink, dlink, rcol, lcol

lcol = (79-width) / 2
rcol = 79 - lcol
dlink=chr(209)
ulink=chr(207)
@ 3,lcol say dlink
@ 3,rcol say dlink
@ 4,lcol TO 20,lcol
@ 4,rcol TO 20,rcol
@ 21,lcol SAY ulink
@ 21,rcol SAY ulink

RETURN

******************************************************************

procedure QBLAYOUT

* Q B L A Y O U T

* layout  general header routine
PARAMETERS heading

CLEAR
* @  1,0 to 1,79 double
@ 21,0 to 21,79 double
@  23,0 say qbtitle
@  23,80-len(qbdate) say qbdate
@  3,0 to 3,79 double
set color to (COLHEAD)
@ 22,centre(trim(heading),79) say trim(heading)
set color to (COLNORM)

RETURN

******************************************************************

procedure QBREAD
*  Q B R E A D
*  Routine to check whether a bunch of fields have been modified
parameters MSG, MSG2
PRIVATE mpos,mess
MESS=trim(MSG)+" - Hit Esc to Abort"
if pcount()<2
    MSG2 = "Move:  , End: ┘ (field), PgDn (screen)"
endif
DO QBCLMESS
SET color to (COLBRIGHT)

@ QBMSGLIN,centre(trim(mess),79) say trim(mess)
if .not. empty(MSG2)
    @ QBMSGLIN+1,centre(trim(MSG2),79) say trim(MSG2)
endif

set color to (COLNORM)
read
GETOUT = (lastkey()=27)
CHANGED = updated()
DO QBCLMESS

return

******************************************************************

procedure QBPUTL

*   Q B P U T L
*   Used to output print lines and control page throws
parameters LSKIP, LINE      && No lines to skip first, Output line
private LCOUNT, PVAR
LCOUNT = 1

if GETOUT
    return
endif
*   Public variable references (defined amd released in QBPRCTL):

*   PAGENO => current page number
*   PLENGTH => no lines to page
*   PLINE => current line no
*   PHEAD1...PHEADn => header text lines for each page
*   PHEADn that are missing become line feeds
*   PHEAD => no header lines
*   PDEST => Screen, Printer, File
*   PFOOT1...PFOOTn => footer text lines for each page
*   PFOOT => no footer lines
if LINE="PLENGTH"
    PLENGTH = LSKIP
    return
endif
if LINE="PWIDTH"
    PWIDTH = LSKIP
    return
endif
if LINE="EJECT"
    PLINE = PLENGTH + 1
    LINE=""
endif

*       End of Page

if (PLINE + LSKIP)>PLENGTH

    if .not. PSTART
        for LCOUNT=1 to PFOOT
            PVAR = "PFOOT"+str(LCOUNT,1)
            if type(PVAR)<>"C"         && Did we define it?
                ?
            else
                EXEC = &PVAR
                ? &EXEC                  && Execute Macro for footer
            endif
        next
        LCOUNT = 1
        do case
        case PDEST="S"
            if QBYESNO("Continue listing? (Y/N)")="N"
                GETOUT = .t.
                return
            endif
            clear
            @ 3,0 say ""
        case PDEST="P"
            eject
        endcase
    else
        if PDEST="S"
            clear
            @ 3,0 say ""
        endif
        PLENGTH = PLENGTH - (PHEAD + PFOOT)
        PSTART = .f.
    endif

    do while LCOUNT<=PHEAD
        PVAR = "PHEAD"+str(LCOUNT,1)
        if type(PVAR)<>"C"         && Did we define it?
            ?
        else
            if len(&PVAR)<PWIDTH-9 .and. LCOUNT=1
                ? &PVAR + space(PWIDTH-10-len(PHEAD1)) + "Page"+str(PAGENO,4)
            else
                ? &PVAR
            endif
        endif
        LCOUNT = LCOUNT + 1
    enddo
    PAGENO = PAGENO + 1
    PLINE = 0
    LCOUNT = 1

endif

for LCOUNT=1 to LSKIP
    ?
next

PLINE = PLINE + LSKIP

if len(LINE)>PWIDTH
    LINE = substr(LINE,1,PWIDTH)
endif

?? LINE

return

******************************************************************

procedure QBPUTH

*   Q B P U T H
*   Used to define page headings
parameters HEADNO, HLINE      && Heading lineno, head line
private PVAR

*   Public variable references:

*   PAGENO => current page number
*   PLENGTH => no lines to page
*   PLINE => current line no
*   PHEAD1...PHEADn => header text lines for each page
*   PHEAD => no header lines
*   PDEST => Screen, Printer, File

PVAR = "PHEAD"+str(HEADNO,1)
&PVAR = HLINE

PHEAD = max(PHEAD+1,HEADNO)

return

******************************************************************

procedure QBPUTF

*   Q B P U T F
*   Used to define page and grand totals
parameters FOOTNO, FLINE      && Footer lineno, Foot line
private PVAR

*   Public variable references:

*   PAGENO => current page number
*   PLENGTH => no lines to page
*   PLINE => current line no
*   PHEAD1...PHEADn => header text lines for each page
*   PHEAD => no header lines
*   PDEST => Screen, Printer, File
*   PFOOT1...PFOOTn => footer text lines for each page
*   PFOOT => np footer lines

PVAR = "PFOOT"+str(FOOTNO,1)
&PVAR = FLINE

PFOOT = FOOTNO

return

******************************************************************

procedure QBWIPE

*       QBWIPE
*       Wipe out all the fields in a record
DUMMY = ""
N = fcount()
declare FNAME[N], FTYPE[N], FWIDTH[N]

AFIELDS(FNAME, FTYPE, FWIDTH, DUMMY)

for I=1 to N

    do case
    case FTYPE[I]$"CM"
        NULVAR = " "
    case FTYPE[I]="D"
        NULVAR = ctod("")
    case FTYPE[I]="N"
        NULVAR = 0
    case FTYPE[I]="L"
        NULVAR = .f.
    endcase
    CURFLD = FNAME[I]
    replace &CURFLD with NULVAR
next

return

******************************************************************

procedure QB2DATES

*       Q B 2 D A T E S
*       get two dates if one is blank  set limits..
parameters MESS, R1, C1, D1, R2, C2, D2
if D1=ctod("01/1/87")
    D1 = ctod("")
endif
if D2=ctod("31/12/99")
    D2 = ctod("")
endif

do while .t.
    @ R1, C1 get D1 picture "@K"
    @ R2, C2 get D2 picture "@K"
    do QBREAD with MESS

    if D2=ctod("")
        D2 = ctod("31/12/99")
    endif

    do case
    case GETOUT
        exit
    case D1>D2
        do QBMESS with "First date is after Second",COLFLASH,3
    case D1=ctod("")
        D1 = ctod("01/01/87")
        exit
    otherwise
        exit
    endcase
enddo

return

******************************************************************

function QBMENU

*   Q B M E N U . P R G
* Procedure to get menu choice from user -
* returns both keystroke and choice no.
PARAMETERS menuname, width
PRIVATE scol, mrow, maxlen, lpos, cpos, nchar, m, i
scol=5+(79-width)/2
mrow=8
maxlen=0
i=0
lpos=1
qbkey=0
if QBCHOICE=0
    QBCHOICE=1
endif

* SET exact off
set message to 1 CENTER
* SELECT 9
set color to (COLMENU)
use qbinfo index qbinfo
set softseek on
SEEK  trim(menuname)
if ! eof()
    DO WHILE (substr(qbinfkey,1,7)=menuname) .AND. (.NOT. eof())
        i = i + 1
        @ mrow, scol PROMPT trim(QBTEXT) MESSAGE trim(WHATITDOES)
        mrow = mrow + 1
        SKIP
    ENDDO
endif
IF i=0
    DO qbmess WITH "No valid menu choices available", colflash,5
    qbkey = 27
    qbchoice = 0
    use
    RETURN 0
else
    MENU to QBCHOICE
    SEEK substr(menuname,1,7)+str(qbchoice,1)
    qbproc = qbtext
    use
ENDIF
if QBCHOICE=0
    QBKEY=27
endif
set softseek off

set color to (COLNORM)
* SET exact on

RETURN QBCHOICE

******************************************************************

procedure QBPRCTL

*     Q B P R C T L
*     Control Printing
PARAMETERS  choice
fname=space(8)
public PAGENO, PHEAD, PFOOT, PSTART, PDEST
PAGENO = 1
PHEAD = 0
PFOOT = 0
PSTART = .t.

if GETOUT
    close database
    return
endif

* If the choice is specified it just goes ahead and does it using the last part
* of choice as the file name, if not you are asked which to use if it's a file
* then you are prompted for the name.

do case
case len(trim(choice))=0
    PDEST=" "
    SET console ON
    SET alternate OFF
    CHOICE = substr("SPFQ",QBPROMPT("Screen|Printer|File|Quit|","Choose output destination",1),1)
    if CHOICE="Q"
        GETOUT=.t.
        return
    endif
case len(trim(choice))>2
     fname=substr(choice,3,len(choice)-2)
endcase

choice=substr(choice,1,1)
IF choice$"PSF"
    PDEST = CHOICE
    do case
    case CHOICE="S"
        PLENGTH = 22
        PWIDTH = 79
    otherwise
        PLENGTH = 55
        PWIDTH = 132
    endcase
    PLINE = PLENGTH + 1
    PHEAD = 0
ENDIF

DO CASE
CASE choice="S"
    DO qbmess WITH "Preparing Report",colflash,0
CASE  choice="P"
    DO qbmess WITH "Printing Report",colflash,0
    do while .not. isprinter()
        ACTION = QBPROMPT("Continue|Quit|","Printer is not ready - correct and continue or Quit",1)
        if ACTION=2 .or. QBRESP="Q"
            GETOUT = .t.
            return
        endif
    enddo
    SET print ON
    SET console OFF
    ? TPSET1            && Begin print code
CASE CHOICE="F"
    IF len(choice)>1
        fname = trim(substr(choice,3,len(choice-2)))
    ELSE
        DO qbclmess
        @ QBMSGLIN, 26 SAY "Enter file name: " GET fname PICTURE "NNNNNNNN"
        READ
    ENDIF
    if .not. "."$fname
        fname = upper(trim(fname)) + ".TXT"
    endif
    DO qbmess WITH "Sending Report to file "+fname,colflash,0
    SET alternate TO &fname
    SET console OFF
    SET alternate ON
CASE choice="R"                     && Reset
    SET print OFF
    SET console ON
    store "" to PHEAD1, PHEAD2, PHEAD3, PHEAD4, PHEAD5, PHEAD6, PHEAD7, PHEAD8, PHEAD9
    DO CASE
    CASE pdest="F"
        ?
        SET alternate OFF
        CLOSE alternate
    CASE pdest="P"
        SET console OFF
        EJECT
        SET console ON
        SET print OFF
    CASE pdest="S"
        ?
        ?
    ENDCASE
    do QBMESS with FNAME+" - Press a key",colmenu,-1
    DO qbclmess
ENDCASE
TPSET1=PSET2                && reset to system defaults
RETURN

******************************************************************

procedure QBLSTSUN
*       Q B L S T S U N . P R G
*       Find the date last Sunday
PUBLIC lstsun

lstsun = date() - dow(date()) + 1

RETURN

******************************************************************

procedure QBGETD
*       Q B G E T D . P R G
* get a date variable: qbrespd

PARAMETER MSG, default
PRIVATE mpos
mpos=(79-len(MSG))/2
qbrespd=ctod(default)

SET confirm on
do QBCLMESS
@ QBMSGLIN,mpos SAY MSG GET qbrespd
READ
SET confirm off

RETURN

******************************************************************

function QBYESNO
parameters MSG
private RETVAL

do QBCLMESS
set color to (COLBRIGHT)
set cursor off
@ QBMSGLIN,centre(trim(MSG),79) say trim(MSG)

RETVAL = " "
do while .not. RETVAL$"YN"
    RETVAL = upper(chr(inkey()))
enddo
do QBCLMESS
set cursor on

return RETVAL

******************************************************************

function CENTRE
*       Returns column position for Centred heading
parameters cTEXT, WIDTH

if pcount()=1
    WIDTH = 80
endif

COLPOS = max(int((WIDTH-1-len(cTEXT)) / 2),0)

return COLPOS

******************************************************************

procedure QBADBLNK

*   Q B A D B L N K . P R G
* Routine to append blank records
PARAMETERS nrecs
PRIVATE i, adstr

* i = recsize()*nrecs
* IF i>diskspace()
*     adstr = "You have run out of disc space!!"
*     DO qbmess WITH adstr,colflash,0
*     WAIT
*    DO qbquit
* ENDIF

adstr = "Please wait - adding "+str(nrecs,4)+" records"

DO qbmess WITH adstr,colflash,0

i=1
DO WHILE i<=nrecs
    i = i + 1
    APPEND BLANK
ENDDO
DO qbmess WITH " ",colnorm,0

return

******************************************************************
function seekit
parameters cText
seek cText
return ( ! eof() )

*******************************************************************
function blank
parameters xValue
private xReturn

do case
case type( "xValue" ) == "C"
    xReturn = space( len( xValue ) )
case type( "xValue" ) == "N"
    xReturn = 0
case type( "xValue" ) == "L"
    xReturn = .f.
case type( "xValue" ) == "D"
    xReturn = ctod("")
endcase

return xReturn

*******************************************************************
function chrcount
parameters cChar, cString
private iReturn, i
iReturn = 0

for i=1 to len( cString )
    if substr( cString, i, 1 ) == cChar
        iReturn = iReturn + 1
    endif
next

return iReturn

*******************************************************************
function ceiling
parameters nValue
private iReturn, i
iReturn = 0

iReturn = int( nValue + 0.999 )

return iReturn

*******************************************************************
function isDrive
parameters cDrive

return .t.

*******************************************************************
function atnext
parameters cChar, cString, nOcc
private iReturn, i, iCount
store 0 to iReturn, iCount

begin sequence
for i=1 to len( cString )
    if substr( cString, i, 1 ) == cChar
        iReturn = i
        iCount = iCount + 1
        if iCount >= nOcc
            break
        endif                          && if iCount >= nOcc
    endif                              && if substr( cString, i, 1 ) == cChar
next
iReturn = 0
end
return iReturn

*******************************************************************
function center
parameters cString, nWidth
private iLen, cReturn

if type( "nWidth" ) <> "N"
    nWidth = 80
endif                                  && if type( "nWidth" ) <> "N"
iLen = int( ( nWidth - len( alltrim( cString ) ) ) / 2 )

if iLen < 0
    cReturn = substr( cString, 1, nWidth )
else
    cReturn = space( iLen ) + alltrim( cString )
endif                                  && if iLen < 0

return cReturn